home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / LISP / FORMAT.LSP < prev    next >
Encoding:
Text File  |  1993-10-25  |  9.2 KB  |  234 lines
  1. ;; PC Scheme Common Lisp Compatibility Package
  2. ;;
  3. ;; (c) Copyright 1990 Carl W. Hoffman.  All rights reserved.
  4. ;;
  5. ;; This file may be freely copied, distributed, or modified for non-commercial
  6. ;; use provided that this copyright notice is not removed.  For further
  7. ;; information about other utilities for Common Lisp or Scheme, contact the
  8. ;; following address:
  9. ;;
  10. ;;   Carl W. Hoffman, 363 Marlborough Street, Boston, MA 02115, U.S.A.
  11. ;;   Internet: CWH@AI.MIT.EDU    CompuServe: 76416,3365    Fax: 617-262-4284
  12.  
  13. ;; FORMAT, WARN, ERROR
  14.  
  15. ;; To do:
  16. ;;   CERROR
  17. ;;   FORMAT optimizer.  Define FORMAT as a macro, and have #'FORMAT and
  18. ;;   (FUNCTION FORMAT) be functions.  Also, perhaps APPLYF, etc. should
  19. ;;   convert to function form.
  20.  
  21. (defun format (destination control-string &rest arguments)
  22.   (if (null destination)
  23.       (with-output-to-string (destination)
  24.         (format-internal destination control-string arguments))
  25.       (format-internal
  26.         (if (eq destination t) (current-output-port) destination)
  27.         control-string arguments)))
  28.  
  29. (defvar *format-directives* nil)
  30.  
  31. ;; This should be implemented using a resource in case we ever
  32. ;; invoke format recursively or in another task.
  33.  
  34. (defvar format-buffer (make-string 300))
  35.  
  36. (defun-clcp format-internal (output-stream control-string arguments)
  37.   (with-input-from-string (input-stream control-string)
  38.     (do ((index 0)
  39.          (next-arg arguments)
  40.          (format-conditional nil)
  41.          (ch (read-char input-stream nil nil)
  42.              (read-char input-stream nil nil)))
  43.         ((null ch)
  44.          (unless (zerop index)
  45.            (write-string format-buffer output-stream :end index)))
  46.       (if (not (char= ch #\~))
  47.  
  48.           ;; Accumulate ordinary characters in a buffer to reduce
  49.           ;; the number of stream operations.
  50.  
  51.           (unless (eq format-conditional 'false)
  52.             (setf (char format-buffer index) ch)
  53.             (incf index))
  54.  
  55.           ;; For now, just flush the buffer whenever we encounter a format
  56.           ;; directive.  We could optimize further by building the entire
  57.           ;; string inside format.
  58.  
  59.           (progn
  60.             (unless (zerop index)
  61.               (write-string format-buffer output-stream :end index)
  62.               (setq index 0))
  63.             (do ((numeric-arg nil)
  64.                  (atsign-flag nil)
  65.                  (colon-flag  nil)
  66.                  (ch))
  67.                 (nil)
  68.               (setq ch (read-char input-stream nil nil))
  69.               (when (null ch)
  70.                 (error "End of format string in the middle of a directive"))
  71.               (if (and (char<=? #\0 ch) (char<=? ch #\9))
  72.                   (let ((digit (- (char-code ch) (char-code #\0))))
  73.                     (setq numeric-arg
  74.                           (if (null numeric-arg)
  75.                               digit
  76.                               (+ (* numeric-arg 10) digit))))
  77.                   (progn
  78.                     (setq ch (char-upcase ch))
  79.                     (case ch
  80.                       (#\@
  81.                         (when atsign-flag
  82.                           (error "Multiple atsign flags in format directive"))
  83.                         (setq atsign-flag t))
  84.                       (#\:
  85.                         (when colon-flag
  86.                           (error "Multiple colon flags in format directive"))
  87.                         (setq colon-flag t))
  88.                       (#\[
  89.                         (when format-conditional
  90.                           (error "~[ seen inside ~["))
  91.                         (setq format-conditional
  92.                               (if (pop next-arg) 'false 'true))
  93.                         (return nil))
  94.                       (#\]
  95.                         (unless format-conditional
  96.                           (error "~] seen before ~["))
  97.                         (setq format-conditional nil)
  98.                         (return nil))
  99.                       (#\;
  100.                         (unless format-conditional
  101.                           (error "~; seen before ~["))
  102.                         (setq format-conditional
  103.                               (if (eq format-conditional 'false)
  104.                                   'true
  105.                                   'false))
  106.                         (return nil))
  107.                       (else
  108.                         (let ((directive
  109.                                 (cdr (assoc ch *format-directives*))))
  110.                           (unless directive
  111.                             (error "Unimplemented FORMAT directive" c))
  112.                           (unless (eq format-conditional 'false)
  113.                             (setq next-arg
  114.                                   ((eval directive) 
  115.                                    input-stream output-stream next-arg
  116.                                    numeric-arg atsign-flag colon-flag))))
  117.                         (return nil))))))))))
  118.   nil)
  119.  
  120. (defun add-format-directive (char name)
  121.   (let ((pair (assoc char *format-directives*)))
  122.     (if pair
  123.         (setf (cdr pair) name)
  124.         (push (cons char name) *format-directives*))))
  125.  
  126. (defmacro define-format-directive (name char &body body)
  127.   (let ((function-name (symbol-append 'format- name)))
  128.     `(begin
  129.        (define (,function-name input-stream output-stream next-arg
  130.                                numeric-arg atsign-flag colon-flag)
  131.          ,@body
  132.          next-arg)
  133.        (add-format-directive ,char ,function-name))))
  134.  
  135. (define-format-directive ~ #\~
  136.   (dotimes (i (or numeric-arg 1)) (write-char #\~ output-stream)))
  137.  
  138. (define-format-directive % #\%
  139.   (dotimes (i (or numeric-arg 1)) (terpri output-stream)))
  140.  
  141. (define-format-directive & #\&
  142.   (fresh-line output-stream))
  143.  
  144. (define-format-directive newline #\newline
  145.   (when atsign-flag
  146.     (terpri output-stream))
  147.   (unless colon-flag
  148.     (do () (nil)
  149.       (let ((c (read-char input-stream)))
  150.         (unless (char= c #\space)
  151.           (un-read-char c input-stream)
  152.           (return nil))))))
  153.  
  154. (define-format-directive s #\S
  155.   (write (pop next-arg) :stream output-stream :escape t))
  156.  
  157. (define-format-directive a #\A
  158.   (write (pop next-arg) :stream output-stream :escape nil))
  159.  
  160. (defun format-integer (arg output-stream number-format description)
  161.   (unless (integerp arg)
  162.     (error "The argument to ~~~A, ~S, is not an integer."
  163.            description arg))
  164.   (write-string (number->string arg number-format) output-stream))
  165.  
  166. (define-format-directive b #\B
  167.   (format-integer (pop next-arg) output-stream '(int (radix b s)) "B"))
  168.  
  169. (define-format-directive o #\O
  170.   (format-integer (pop next-arg) output-stream '(int (radix o s)) "O"))
  171.  
  172. (define-format-directive d #\D
  173.   (format-integer (pop next-arg) output-stream '(int (radix d s)) "D"))
  174.  
  175. (define-format-directive x #\X
  176.   (format-integer (pop next-arg) output-stream '(int (radix x s)) "X"))
  177.  
  178. ;; Make this inline so that there is one less frame on the stack when
  179. ;; debugging.  Later, we may have a debugger which can hide this frame.
  180.  
  181. (defun-inline error (format-string &rest format-args)
  182.   (scheme-error (apply (function format) nil format-string format-args)))
  183.  
  184. ;; Good enough for now
  185.  
  186. (defvar typespec-alist
  187.   '((array              vector?    "an array")
  188.     (character          char?      "a character")
  189.     (compiled-function  procedure? "a compiled function")
  190.     (cons               pair?      "a cons cell")
  191.     (double-float       float?     "a double-precision floating point number")
  192.     (float              float?     "a floating point number")
  193.     (integer            integer?   "an integer")
  194.     (list               listp      "a list")
  195.     (null               null?      "the empty list")
  196.     (number             number?    "a number")
  197.     (simple-array       vector?    "a simple array")
  198.     (simple-bit-vector  vector?    "a simple bit vector")
  199.     (simple-string      string?    "a simple string")
  200.     (simple-vector      vector?    "a simple vector")
  201.     (standard-char      char?      "a standard character")
  202.     (string             string?    "a string")
  203.     (string-char        char?      "a string character")
  204.     (symbol             symbol?    "a symbol")
  205.     (vector             vector?    "a vector")
  206.     ))
  207.  
  208. (defmacro check-type (place typespec &optional string)
  209.   (let ((typespec-entry (assoc typespec typespec-alist)))
  210.     (unless typespec-entry
  211.       (error "~A is an unrecognized type." typespec))
  212.     (let ((predicate   (cadr typespec-entry))
  213.           (description (or string (caddr typespec-entry))))
  214.       (flet ((result (place-var)
  215.                `(unless (,predicate ,place-var)
  216.                   (error
  217.                     ,(format nil "The value of ~A, ~~S, is not ~A."
  218.                              (if (symbolp place) (symbol-name place) "~A")
  219.                              (if (stringp description) description "~A"))
  220.                     ,@ (if (symbolp place) '() `(',place))
  221.                     ,place-var
  222.                     ,@ (if (stringp description) '() `(,description))))))
  223.         (if (symbolp place)
  224.             (result place)
  225.             `(let ((temp ,place)) ,(result 'temp)))))))
  226.  
  227. (defvar *break-on-warnings* nil)
  228.  
  229. (defun warn (format-string &rest args)
  230.   (format t "~&Warning: ")
  231.   (apply format t format-string args)
  232.   (when *break-on-warnings*
  233.     (bkpt "Warning break" *break-on-warnings*)))
  234.